perm filename DEFMAC[MAC,LSP]2 blob
sn#493492 filedate 1980-01-04 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00009 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 DEFMAC -*-LISP-*-
C00005 00003
C00007 00004
C00012 00005
C00020 00006
C00024 00007
C00032 00008
C00034 00009
C00045 ENDMK
C⊗;
;;; DEFMAC -*-LISP-*-
;;; **************************************************************
;;; ***** NIL ******** DEFUN& and DEFMACRO ***********************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1979 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
(eval-when (eval compile)
(cond ((status nofeature maclisp))
((status macro /#))
((getl '+INTERNAL-/#-MACRO '(SUBR AUTOLOAD))
(setsyntax '/# 'SPLICING '+INTERNAL-/#-MACRO))
((fasload (LISP) SHARPM)))
)
(eval-when (eval compile)
#M (and (not (get 'HERALD 'AUTOLOAD))
(not (get 'HERALD 'MACRO))
(defprop HERALD ((LISP) MACAID FASL) AUTOLOAD))
#Q (and (not (fboundp 'HERALD))
(load '((LISP) MACAID)))
)
(herald DEFMACRO /95)
(DECLARE (*EXPR DEFUN&-ERROR |&r-l/||)
(MAPEX 'T)
(SPECIAL DEFUN&-ERROR |&r-l/||)
(SPECIAL BAD-VARS BOUND-VARS ALL-LOCALS SUPPLIEDP-VARS))
(DECLARE (SPECIAL DEFMACRO-CHECK-ARGS ;These are user-settable
DEFMACRO-DISPLACE-CALL ; switches.
DEFMACRO-FOR-COMPILING
MACRO-EXPANSION-USE
GRIND-MACROEXPANDED
DEFUN&-CHECK-ARGS ))
(DECLARE (*EXPR MACROMEMO MACROFETCH |forget-macromemos/||)
(SPECIAL MACROMEMO MACROEXPANDED))
(OR (BOUNDP 'DEFUN&-CHECK-ARGS) (SETQ DEFUN&-CHECK-ARGS 'T))
(OR (BOUNDP '|&r-l/||) (SETQ |&r-l/|| 'LISTIFY))
(DECLARE (SETQ DEFMACRO-FOR-COMPILING () DEFMACRO-DISPLACE-CALL () ))
;;; WARNING! note that the argument to PAIRP is used twice!
#-NIL (defmacro PAIRP (x) `(AND (NOT (ATOM ,x)) (NOT (HUNKP ,x))))
;;; A loop for going down the VARLIST and consing up forms
;;; stops when the tail is at MORE
;;; Requires some variables to be setup - MORE ARGNO
;;; Provides some variables for the body - VARL
;;; Increments ARGNO
(defmacro MAP-VL (form)
`(DO ((VARL VARLIST (CDR VARL))
(ANSL () (CONS ,form ANSL)))
((EQ VARL MORE) ANSL)
(SETQ ARGNO (1+ ARGNO))))
(DEFUN DEFUN&-ERROR () (ERROR '|Bad variable-list syntax -- DEFUN& |
DEFUN&-ERROR))
#-MACLISP
(AND (NOT (BOUNDP 'DEFUN/&)) (SETQ DEFUN/& (COPYSYMBOL 'DEFUN/& () )))
(DECLARE (SETQ DEFMACRO-FOR-COMPILING 'T DEFMACRO-DISPLACE-CALL 'T))
(COMMENT DEFUN/& for non-MACLISP)
#-MACLISP
(MACRO DEFUN/& (X)
(PROG (NAME VARLIST BODY DEFUN&-ERROR DECLS FLAG VARL)
(SETQ (NAME (NTH 1 X)) (VARLIST (NTH 2 X)) (BODY (CDDDR X)) )
(AND (NOT (ATOM NAME)) (SETQ NAME (CAR NAME)))
(SETQ ARGNO 0)
(COND ((EQ VARLIST 'EXPR) (POP BODY VARLIST))
((MEMQ VARLIST '(MACRO FEXPR))
(ERROR '|Can't DEFUN& for FEXPR or MACRO| (CONS 'DEFUN X))))
(COND ((NULL (SETQ DEFUN&-ERROR VARLIST)) () )
((OR (ATOM VARLIST) (CDR (LAST VARLIST)))
(DEFUN&-ERROR)))
(SETQ VARL VARLIST)
LP1 (COND ((NULL VARL) (RETURN `(DEFUN ,(cdr x)))) ;Simple case
((MEMQ (CAR VARL) '(&OPTIONAL &REST &AUX))
(SETQ FLAG 'T VARL (CDR VARL))
(GO LP1))
('T (OR (SYMBOLP (CAR VARL))
(AND FLAG (NOT (ATOM (CAR VARL))) (SYMBOLP (CAAR VARL)))
(GO LOSE))
(SETQ VARL (CDR VARL))
(GO LP1)))
LOSE (OR (ATOM BODY)
(ATOM (CAR BODY))
(NOT (EQ (CAAR BODY) 'DECLARE))
(SETQ DECLS (LIST (CAR BODY)) BODY (CDR BODY)))
(RETURN
(PROG
(FLAG MORE LETLIST ALLFLATS TMP VARL ARGNO VALUE INSETQS
BOUND-VARS BAD-VARS ALL-LOCALS TEM)
(DECLARE (SPECIAL BAD-VARS BOUND-VARS ALL-LOCALS))
(SETQ VARLIST
(MAP-VL
(COND ((ATOM (CAR VARL))
(OR (SYMBOLP (CAR VARL))
(ERROR '|Non-SYMBOL in varlist - DEFUN&|
(CAR VARL)))
(COND ((AND (NULL FLAG)
(MEMQ (CAR VARL)
'(&OPTIONAL &REST &AUX)))
(SETQ FLAG (CAR VARL)))
('T (PUSH (CAR VARL) BAD-VARS)))
(CAR VARL))
(FLAG
(COND ((ATOM (CAAR VARL))
(OR (SYMBOLP (CAAR VARL))
(ERROR '|Non-SYMBOL in varlist - DEFUN&|
(CAAR VARL)))
(PUSH (SETQ TMP (CAAR VARL)) BAD-VARS))
('T (SETQ BAD-VARS
(*&FLATTENSYMS&* (CAAR VARL) BAD-VARS))
(SETQ TMP (GENSYM))))
(SETQ VALUE (CADAR VARL))
(COND ((NOT (|Certify-no-var-dependency/|| VALUE))
(SETQ VALUE 'DEFUN/&)
(SETQ TEM `(DESETQ ,(caar varl) ,tmp))
(PUSH (COND ((NOT (EQ FLAG '&OPTIONAL)) TEM)
(`(AND (EQ ,tmp DEFUN/&) ,tem)))
INSETQS)
(SETQ ALLFLATS (*&FLATTENSYMS&* (CAAR VARL)
ALLFLATS)))
((NOT (ATOM (CAAR VARL)))
(PUSH `(,(caar varl) ,tmp) LETLIST)))
`(,tmp ,value ,. (cddar varl)))
('T (SETQ BAD-VARS
(*&FLATTENSYMS&* (CAR VARL) BAD-VARS))
(PUSH `(,(car varl) ,(setq tmp (gensym)))
LETLIST)
TMP))))
(SETQ BODY `((LET (,@(nreverse letlist) ,@allflats)
,@(nreverse insetqs) . ,body)))
(RETURN `(DEFUN ,name ,varlist
,@decls
(COMMENT ARGLIST = ,defun&-error)
. ,body))))))
(COMMENT DEFUN/& for MACLISP)
#+MACLISP
(defmacro DEFUN& (NAME-ARG VARLIST &rest BODY)
(LET ( (DCA DEFUN&-CHECK-ARGS)
(MIN 0) (MAX 262143.) (ARGNO 0) DEFUN&-ERROR SUPPLIEDP-VARS
LEXPRVAR ALLFLATS ALLVARS MORE LETLIST DECLS INSETQS TMP)
(COND ((EQ VARLIST 'EXPR) (POP BODY VARLIST))
((MEMQ VARLIST '(MACRO FEXPR))
(ERROR '|Can't DEFUN& for FEXPR or MACRO|
`(DEFUN/& ,name-arg ,varlist ,. body))))
(COND ((NULL (SETQ DEFUN&-ERROR VARLIST)) () )
((OR (ATOM VARLIST) (CDR (LAST VARLIST)))
(DEFUN&-ERROR)))
(OR (ATOM BODY)
(ATOM (CAR BODY))
(NOT (EQ (CAAR BODY) 'DECLARE))
(SETQ DECLS (LIST (CAR BODY)) BODY (CDR BODY)))
(COND ((SETQ MORE (OR (MEMQ '&OPTIONAL VARLIST) (MEMQ '&REST VARLIST)))
(SETQ LEXPRVAR (GENSYM)
LETLIST (MAP-VL `(,(car varl) (ARG ,argno)))
MIN (LENGTH LETLIST)
MAX (COND ((MEMQ '&REST MORE) () )
((+ MIN (- (LENGTH (CDR MORE))
(LENGTH (MEMQ '&AUX (CDR MORE)))))))
LETLIST (NRECONC LETLIST
(COND ((EQ (POP MORE) '&OPTIONAL)
(|&o-l/|| MORE ARGNO LEXPRVAR))
((|&r-l/|| MORE ARGNO LEXPRVAR))))
VARLIST LEXPRVAR ))
('T (COND ((SETQ MORE (MEMQ '&AUX VARLIST))
(SETQ VARLIST (|copy-til/|| VARLIST MORE))
(SETQ LETLIST (|&a-l/|| (CDR MORE)))))
(SETQ MAX (SETQ MIN (LENGTH VARLIST)))
(COND ((DO L VARLIST (CDR L) (NULL L)
(AND (CAR L) (NOT (SYMBOLP (CAR L))) (RETURN 'T)))
(SETQ VARLIST
(MAPCAR
'(LAMBDA (VAR)
(COND ((OR (NULL VAR) (SYMBOLP VAR)) VAR)
('T (SETQ ALLFLATS (*&FLATTENSYMS&*
VAR
ALLFLATS))
(PUSH `(DESETQ ,var
,(setq tmp (gensym)))
INSETQS)
TMP)))
VARLIST) )))))
(COND (SUPPLIEDP-VARS
(SETQ ALLFLATS (NCONC (MAPCAR 'CAR SUPPLIEDP-VARS) ALLFLATS))
(SETQ BODY (NCONC (MAPCAR
'(LAMBDA (X)
`(AND (> ,lexprvar ,(1- (cdr x)))
(SETQ ,(caar x) 'T)))
SUPPLIEDP-VARS)
BODY)) ))
(MAP '(LAMBDA (X) (AND (CAR X) (MEMQ (CAR X) (CDR X)) (DEFUN&-ERROR)))
(SETQ ALLVARS (*&FLATTENSYMS&*
(MAPCAR 'CAR LETLIST)
(COND ((ATOM VARLIST) ALLFLATS)
((*&FLATTENSYMS&* VARLIST ALLFLATS))))))
(COND (LETLIST
(LET ((SVARS (MAPCAN '(LAMBDA (X)
(AND (NOT (ATOM X))
(EQ (CAR X) 'SPECIAL)
(APPEND (CDR X) () )))
(CDAR DECLS)))
(ALL-LOCALS 'T)
(BOUND-VARS)
(BAD-VARS ALLVARS)
(FLAG) )
(DECLARE (SPECIAL BAD-VARS BOUND-VARS ALL-LOCALS))
(MAPC '(LAMBDA (Y)
(AND (OR (GET Y 'SPECIAL)
;This clause would allow more extended
; declarations of special variables, by
; adding names on this special list
;(MEMQ Y SPECIAL-VARIABLES)
(MEMQ Y SVARS))
(SETQ ALL-LOCALS () )))
BAD-VARS)
(MAP '(LAMBDA (L)
;Analyze variable dependencies in the left-to-right
;view of the default values for &optionals and &auxs
(COND ((NOT (|Certify-no-var-dependency/|| (CADAR L)))
(SETQ FLAG 'T)
(SETQ ALLFLATS (*&FLATTENSYMS&* (CAAR L)
ALLFLATS))
(PUSH `(DESETQ ,(caar l) ,(cadar l))
INSETQS)
(RPLACA L () ))))
LETLIST)
(AND FLAG (SETQ LETLIST (DELQ () LETLIST))) )))
(COND ((OR ALLFLATS LETLIST)
(SETQ BODY `((LET (,@(nreverse letlist) ,@allflats)
,@(nreverse insetqs) . ,body)))))
(COND ((AND DCA LEXPRVAR (OR MAX (NOT (= 0 MIN))))
;;If wrong number of arguments, enter an error handler.
;;A form may be returned so eval it and return as
;;value of function.
(LET ((MSG)
(PREDICATE)
(CHECKARGS `(LIST (CONS ',name-arg (LISTIFY ,lexprvar))
',defun&-error)))
(COND ((AND MAX (NOT (= 0 MIN)))
(SETQ MSG `(COND ((> ,lexprvar ,max)
'|Too many arguments supplied |)
('|Too few arguments supplied |)))
(SETQ PREDICATE
(COND ((= MAX MIN)
`(NOT (= ,lexprvar ,max)))
('T `(OR (< ,lexprvar ,min)
(> ,lexprvar ,max))))))
(MAX
(SETQ MSG ''|Too many arguments supplied |)
(SETQ PREDICATE `(> ,lexprvar ,max)))
((NOT (= 0 MIN))
(SETQ MSG ''|Too few arguments supplied |)
(SETQ PREDICATE `(< ,lexprvar ,min))))
(SETQ BODY
`((COND (,predicate
(EVAL (ERROR ,msg ,checkargs 'WRNG-NO-ARGS)))
('T ,@body)))))))
(SETQ BODY `(DEFUN ,name-arg ,varlist
,@decls
(COMMENT ARGLIST = ,defun&-error)
,@body))
;;If DEFUN&-CHECK-ARGS is NIL, then let APPLY check the number
;;of args via the ARGS mechanism.
(COND ((AND (NOT DCA)
LEXPRVAR
(OR MAX (NOT (= MIN 0)))
(ATOM NAME-ARG))
(SETQ BODY `(PROGN 'COMPILE
,body
(ARGS ',name-arg '(,min . ,(or max 776)))))))
BODY))
(comment Helper Funs for non-MACLISP DEFUN/&)
#+MACLISP (progn 'compile
;;; Process a varlist that follows an &OPTIONAL.
;;; The remainder may have an &REST and/or and &AUX.
;;; ARGNO is one less than the index number of the argument at
;;; the first of the list
(DEFUN |&o-l/|| (VARLIST ARGNO LEXPRVAR)
(AND (MEMQ '&OPTIONAL VARLIST) (DEFUN&-ERROR))
(LET ((MORE (OR (MEMQ '&REST VARLIST) (MEMQ '&AUX VARLIST))) TMP )
(NRECONC (MAP-VL (COND ((SYMBOLP (CAR VARL))
`(,(car varl) (AND (> ,lexprvar ,(1- argno))
(ARG ,argno))))
((COND ((PROG2 (SETQ TMP () ) (ATOM (CAR VARL))))
((ATOM (CDAR VARL)) (CDAR VARL))
((ATOM (SETQ TMP (CDDAR VARL))) TMP)
((OR (CDR TMP)
(NULL (CAR TMP))
(NOT (SYMBOLP (CAR TMP))))))
(DEFUN&-ERROR))
('T (AND TMP (PUSH (CONS TMP ARGNO) SUPPLIEDP-VARS))
`(,(caar varl) (COND ((> ,lexprvar ,(1- argno))
(ARG ,argno))
(,(cadar varl)))))))
(COND ((NULL MORE) () )
((EQ (POP MORE) '&REST) (|&r-l/|| MORE ARGNO LEXPRVAR))
('T (|&a-l/|| MORE))))))
;;; Process a varlist that follows an &REST.
;;; ARGNO is one less than the index number of argument at the head of the list
(DEFUN |&r-l/|| (VARLIST ARGNO LEXPRVAR)
(AND (OR (NOT (SYMBOLP (CAR VARLIST)))
(MEMQ '&REST VARLIST)
(MEMQ '&OPTIONAL VARLIST)
(EQ (CAR VARLIST) '&AUX) )
(DEFUN&-ERROR))
(SETQ ARGNO (COND ((= ARGNO 0) `(,|&r-l/|| ,lexprvar)) ;|&r-l/|| = LISTIFY
(`(AND (> ,lexprvar ,argno)
(,|&r-l/|| (- ,argno ,lexprvar))))))
(SETQ LEXPRVAR (COND ((NULL (CDR VARLIST)) () )
((EQ (CADR VARLIST) '&AUX) (|&a-l/|| (CDDR VARLIST)))
((DEFUN&-ERROR))) )
(COND ((NULL (CAR VARLIST)) LEXPRVAR)
((CONS `(,(car varlist) ,argno) LEXPRVAR))))
;;; Process a varlist that follows an &AUX.
(DEFUN |&a-l/|| (VARLIST)
(MAPCAR '(LAMBDA (VAR)
(COND ((MEMQ VAR '(&AUX &REST &OPTIONAL)) (DEFUN&-ERROR))
((SYMBOLP VAR) `(,var () ))
((ATOM VAR) (DEFUN&-ERROR))
(`(,(car var) ,(cadr var))) ))
VARLIST))
) ;end of #+MACLISP (progn 'compile ...)
(comment |Certify-no-var-dependency/||)
#+MACLISP
(DEFUN |APPLICABLEP-cnvd/|| MACRO (X) `(GETL ,(cadr x) '(SUBR LSUBR)))
#-MACLISP
(DEFUN |APPLICABLEP-cnvd/|| (X)
(AND (SYMBOLP X)
(SUBRP (FSYMEVAL X))
#Q (NOT (MEMQ X '(COND PROG SETQ OR AND STATUS SSTATUS SIGNP DO PSETQ
ERRSET CATCH *CATCH CATCHALL CATCH-BARRIER )))
))
#M (DEFUN |cnvd-checkautoload/|| (FORM)
(COND ((OR (ATOM FORM) (NOT (SYMBOLP (CAR FORM)))) () )
((AND (GET (CAR FORM) 'AUTOLOAD)
(NOT (GETL (CAR FORM) '(SUBR FSUBR LSUBR MACRO))))
(FUNCALL AUTOLOAD (CONS (CAR FORM) (GET (CAR FORM) 'AUTOLOAD)))
'T)))
#-MACLISP (MACRO |cnvd-checkautoload/|| (FORM) '() )
(DEFUN |Certify-no-var-dependency/|| (FORM)
(DECLARE (SPECIAL BAD-VARS BOUND-VARS ALL-LOCALS))
; This functions says "yes" if the evaluation of FORM does not depend upon
; any of the variables in BAD-VARS, and where ALL-LOCALS is a flag with
; non-null meaning that there are no special variables in the BAD-VARS
; Requires these three special variables to be bound by the caller:
; BAD-VARS (sart at list of variables for which dependency is checked)
; BOUND-VARS (start at () )
; ALL-LOCALS (start at 'T)
(PROG ()
A (SETQ FORM (MACROEXPAND FORM))
(AND (|cnvd-checkautoload/|| FORM) (GO A))
(COND ((ATOM FORM) ;True iff FORM can be
(RETURN (COND ((NOT (SYMBOLP FORM))) ; guaranteed not have
((MEMQ FORM BOUND-VARS)) ; any free references
((MEMQ FORM BAD-VARS) () ) ; to any variable in
('T)))) ; BAD-VARS
((EQ (CAR FORM) 'QUOTE) (RETURN 'T)))
(AND (COND ((NOT (ATOM (CAR FORM)))
(COND ((EQ (CAAR FORM) 'LAMBDA)
(LET ((BOUND-VARS (APPEND
(COND ((ATOM (CADAR FORM))
(LIST (CADAR FORM)))
((CADAR FORM)))
BOUND-VARS))
(X (CONS 'PROGN (CDDAR FORM))))
(|Certify-no-var-dependency/|| X)))
((LET* ((OX (CAR FORM)) (A (CAR OX)) (D (CDR OX))
(X (MACROEXPAND OX)))
(AND (EQ X OX)
(EQ A (CAR X))
(EQ D (CDR X))
(RETURN () ))
(SETQ FORM (CONS X (CDR FORM)))
(GO A)))))
((MEMQ (CAR FORM) '(FUNCTION *FUNCTION))
(COND ((ATOM (CADR FORM)) (RETURN 'T))
('T (SETQ FORM (CADR FORM)) (GO A))))
((SYMBOLP (CAR FORM))
(COND ((NOT (SYSP (CAR FORM))) () )
((|APPLICABLEP-cnvd/|| (CAR FORM))
(COND ((MEMQ (CAR FORM) '(FUNCALL APPLY MAPC MAP
MAPCON MAPLIST MAPCAR
MAPCAN MAPATOMS *APPLY
MAPF MAPVECTOR
))
(AND (NOT (ATOM (CADR FORM)))
(SYMBOLP (CADADR FORM))
(SYSP (CADADR FORM))))
((MEMQ (CAR FORM) '(EVAL *EVAL READ *READ))
() )
('T)))
((MEMQ (CAR FORM) '(OR AND ERRSET CATCH *CATCH
CATCHALL CATCH-BARRIER
UNWIND-PROTECT )))
((MEMQ (CAR FORM) '(PROG1 PROG2 PROGN PROGV)))
((OR (MEMQ (CAR FORM) '(STATUS SSTATUS SIGNP))
(AND (EQ (CAR FORM) 'DO)
(SYMBOLP (CADR FORM))))
(SETQ FORM (CDR FORM))
'T) )))
(RETURN (|map-cnvd/|| (CDR FORM) 'T)))
(RETURN
(COND ((NOT (SYMBOLP (CAR FORM))) () )
((MEMQ (CAR FORM) '(SETQ PSETQ))
(DO ((Y (CDDR FORM) (CDDR Y)))
((NULL Y) 'T)
(AND (NOT (|Certify-no-var-dependency/|| (CAR Y)))
(RETURN () ))))
((EQ (CAR FORM) 'COND)
(DO ((Y (CDR FORM) (CDR Y)))
((NULL Y) 'T)
(AND (NOT (|map-cnvd/|| (CAR Y) 'T)) (RETURN () ))))
((EQ (CAR FORM) 'PROG)
(LET ((BOUND-VARS (APPEND (CADR FORM) BOUND-VARS)))
(|map-cnvd/|| (CDDR FORM) () )))
((AND (EQ (CAR FORM) 'DO) (OR (NULL (CADR FORM))
(NOT (ATOM (CADR FORM)))))
(LET ((IL (MAPCAR '(LAMBDA (X)
(COND ((ATOM X) (LIST X () () ))
((LIST (CAR X) (CADR X) (CADDR X)))))
(CADR FORM))))
(AND (|map-cnvd/|| (MAPCAR 'CADR IL) 'T)
(LET ((BOUND-VARS (NCONC (MAPCAR 'CAR IL) BOUND-VARS)))
(AND (|map-cnvd/|| (MAPCAR 'CADDR IL) 'T)
(|map-cnvd/|| (CDDDR FORM) () ))))))
((MEMQ (CAR FORM) '(CASEQ TYPECASEQ))
(COND ((NOT (|Certify-no-var-dependency/|| (CADR FORM))) () )
((DO ((Y (CDDR FORM) (CDR Y)))
((NULL Y) 'T)
(AND (NOT (|map-cnvd/|| (CDAR Y) 'T))
(RETURN () ))))))
(ALL-LOCALS (|map-cnvd/|| (CDR FORM) 'T))
;;; If all the BAD-VARS are local, then this line will permit
;;; the use of random functions in FORM, since there can be no
;;; non-lexical variable dependencies.
))))
(DEFUN |map-cnvd/|| (FORM SYMBOLP)
(DO ((Y FORM (CDR Y))) ;Requires two vars to be setup
((NULL Y) 'T) ; BAD-VARS, and BOUND-VARS
(AND (NOT (|Certify-no-var-dependency/|| (CAR Y)))
(OR SYMBOLP (NOT (SYMBOLP (CAR Y))))
(RETURN () ))))
(comment maclisp MACRO and common funs)
;;; The "DEFMACRO" portion of this file must
;;; 1) COMPILE in both QCOMPL and QCMP, and
;;; 2) RUN in both MACLISP and LISPM.
;;; USE CAUTION!!
;;; Just for starters, consider the case of ((FIND it) 1), where
;;; FIND is a macro s.t. (FIND it) ==> FOO,
#M (defmacro MACRO (name &REST bvl-body)
(let ((dfc defmacro-for-compiling) tem)
(cond ((not (atom name))
(setq tem (getl name '(DEFMACRO-FOR-COMPILING))
name (car name))
(and tem (setq dfc (eval (cadr tem))))))
`(DEFUN ,@(cond (dfc `((,name MACRO)))
('t `(,name MACRO)))
,. bvl-body)))
;;; Functions on this page needed by both DEFUN& and DEFMACRO
(DEFUN *&FLATTENSYMS&* (X L)
; String together the (non-null) SYMBOLs of an S-EXP into a linear list.
(COND ((ATOM X)
(COND ((AND X (SYMBOLP X)) (CONS X L))
('T L)))
('T (*&FLATTENSYMS&* (CAR X) (*&FLATTENSYMS&* (CDR X) L)))))
(DEFUN |copy-til/|| (X Y)
; Copy top level of list x down to the tail of x that is EQ to y
(COND ((OR (NULL X) (EQ X Y)) () )
('T (CONS (CAR X) (|copy-til/|| (CDR X) Y)))))
(comment DEFMACRO)
(defmacro DEFMACRO (&rest X) (|defmacro-1/|| X DEFMACRO-DISPLACE-CALL))
(defmacro DEFMACRO-DISPLACE (&rest X) (|defmacro-1/|| X 'T))
(DEFUN |defmacro-1/|| (X DDC)
(LET ( (NAMELIST (CAR X)) (DEF-ARGLIST (CADR X)) (BODY (CDDR X))
(MIN 0) (MAX 262143.) (DCA DEFMACRO-CHECK-ARGS)
NAME OPT-ARGLIST OPT-INISL DEFAULTOPTSP RESTARG RESTARGP
MACROARG AUXVARS AUX-INISL ARGLIST ALLFLATS ARGSCHECK
SEQUENCER TEM BADP )
(COND ((ATOM NAMELIST) (SETQ NAME NAMELIST))
('T (SETQ NAME (CAR NAMELIST))
(AND (SETQ TEM (GETL NAMELIST '(DEFMACRO-CHECK-ARGS)))
(SETQ DCA (EVAL (CADR TEM))))
(AND (SETQ TEM (GETL NAMELIST '(DEFMACRO-DISPLACE-CALL)))
(SETQ DDC (EVAL (CADR TEM))))
(SETQ TEM (GETL NAMELIST '(DEFMACRO-FOR-COMPILING)))
(SETQ NAMELIST
#-LISPM (COND ((NULL TEM) NAME)
(`(,name DEFMACRO-FOR-COMPILING ,.
(and (eval (cadr tem)) '(T)))))
#+LISPM NAME
) ))
(SETQ MACROARG (IMPLODE (NCONC (EXPLODEN NAME)
'(/- M A C R O A R G))))
(SETQ ARGLIST
(COND ;Next two clauses permit forms like "(DEFMACRO FOO X ...)"
; and "(DEFMACRO FOO (<various-args> . X) ...)"
((ATOM DEF-ARGLIST) `(&REST ,def-arglist))
((CDR (SETQ TEM (LAST DEF-ARGLIST)))
`(,.(|copy-til/|| def-arglist tem) ,(car tem) &REST ,(cdr tem)))
('T DEF-ARGLIST)))
;Process a "&WHOLE" argument, if present
(COND ((SETQ TEM (MEMQ '&WHOLE ARGLIST))
(COND ((OR (ATOM (CDR TEM))
(MEMQ (CADR TEM) '(&AUX &OPTIONAL &REST &WHOLE)))
(SETQ BADP 'T))
('T (SETQ ARGLIST (NCONC (|copy-til/|| ARGLIST TEM)
(CDDR TEM)))
(AND (NULL ARGLIST) (SETQ DCA () ))
(COND ((NULL (CADR TEM)) () )
((NOT (SYMBOLP (CADR TEM)))
(COND ((PAIRP (CADR TEM))
(SETQ ALLFLATS (*&FLATTENSYMS&*
(CADR TEM)
ALLFLATS)
AUX-INISL `((DESETQ ,(cadr tem)
,macroarg))))
('T (SETQ BADP 'T))))
('T (SETQ MACROARG (CADR TEM))))))))
;Process "&AUX" arguments, if present
(COND ((SETQ TEM (MEMQ '&AUX ARGLIST))
(SETQ ARGLIST (|copy-til/|| ARGLIST TEM))
(MAPC '(LAMBDA (X)
(SETQ ALLFLATS
(COND ((ATOM X) (CONS X ALLFLATS))
('T (PUSH `(DESETQ ,(car x) ,(cadr x))
AUX-INISL)
(*&FLATTENSYMS&* (CAR X) ALLFLATS)))))
(SETQ AUXVARS (CDR TEM)))
(SETQ AUX-INISL (NREVERSE AUX-INISL))))
;Process any &OPTIONAL and &REST arguments
(COND ((SETQ TEM (COND ((MEMQ '&OPTIONAL ARGLIST))
((SETQ RESTARGP (MEMQ '&REST ARGLIST)))))
(SETQ ARGLIST (|copy-til/|| ARGLIST TEM)
MIN (LENGTH ARGLIST))
(COND (RESTARGP
(SETQ RESTARG (CADR RESTARGP))
(AND (OR (AND RESTARG (NOT (SYMBOLP RESTARG)))
(CDDR RESTARGP))
(SETQ BADP 'T)))
('T ;so (EQ (CAR TEM) '&OPTIONAL)
(SETQ OPT-ARGLIST (CDR TEM))
(COND ((MEMQ '&OPTIONAL OPT-ARGLIST) (SETQ BADP 'T))
((SETQ RESTARGP (MEMQ '&REST OPT-ARGLIST))
(SETQ OPT-ARGLIST (|copy-til/|| OPT-ARGLIST
RESTARGP))
(SETQ RESTARG (CADR RESTARGP))
(AND (OR (AND RESTARG (NOT (SYMBOLP RESTARG)))
(CDDR RESTARGP))
(SETQ BADP 'T)))
('T (SETQ MAX (+ MIN (LENGTH OPT-ARGLIST)))))
(SETQ OPT-ARGLIST
(MAPCAR
'(LAMBDA (X)
(COND ((OR (NULL X) (SYMBOLP X))
(PUSH () OPT-INISL)
X)
('T (SETQ DEFAULTOPTSP 'T)
(AND
(COND ((AND (CDR X) (ATOM (CDR X))))
((NULL (CDDR X)) () )
((OR (ATOM (CDDR X))
(NOT (SYMBOLP (CADDR X)))))
('T ; Find the "suppliedp" var
(PUSH (CADDR X) ALLFLATS)
(CDDDR X)))
(SETQ BADP 'T))
;((A . B) (MUMBLEIFY)) so find A & B
(SETQ ALLFLATS (*&FLATTENSYMS&*
(CAR X)
ALLFLATS))
(PUSH X OPT-INISL)
() )))
OPT-ARGLIST))) )
(SETQ ARGLIST (APPEND ARGLIST OPT-ARGLIST RESTARG)))
('T (SETQ MIN (SETQ MAX (LENGTH ARGLIST)))))
(MAP '(LAMBDA (X) (AND (CAR X) (MEMQ (CAR X) (CDR X)) (SETQ BADP 'T)))
(*&FLATTENSYMS&* ARGLIST ALLFLATS))
(AND BADP (ERROR '|Bad argument pattern in use of DEFMACRO|
(cons 'DEFMACRO X)))
(COND ((NOT DCA))
((AND (= MIN 0) (= MAX 262143.)))
((= MIN MAX)
(SETQ ARGSCHECK `(= (LENGTH ,macroarg) ,(1+ min))))
('T (AND (NOT (= MIN 0))
(SETQ ARGSCHECK `(NOT (< (LENGTH ,macroarg) ,(1+ min)))))
(COND ((= MAX 262143.))
('T (SETQ TEM `(NOT (> (LENGTH ,macroarg)
,(1+ max))))
(SETQ ARGSCHECK
(COND ((NULL ARGSCHECK) TEM)
(`(AND ,argscheck ,tem))))))))
(AND ARGSCHECK
(SETQ ARGSCHECK `((AND (NOT ,argscheck)
(ERROR '|Wrong number args to a macro call|
,macroarg)))))
(COND ((NOT (AND OPT-ARGLIST DEFAULTOPTSP)) (SETQ OPT-INISL () ))
((SETQ SEQUENCER (GENSYM)
OPT-INISL ;currently in reverse order
(MAPCAN
'(LAMBDA (X)
`((SETQ ,sequencer (CDR ,sequencer))
,@(and x `((DESETQ ,(car x)
(COND (,sequencer
,@(and (cddr x)
`((SETQ ,(caddr x) 'T)))
(CAR ,sequencer))
(,(cadr x))))))))
(DO ((L OPT-INISL (CDR L))) ((OR (NULL L) (CAR L)) L))))
(SETQ OPT-INISL (NREVERSE (CDR OPT-INISL)))
(PUSH `(SETQ ,sequencer ,(cond ((= min 0) `(CDR ,macroarg))
(`(NTHCDR (1+ ,min) ,macroarg))))
OPT-INISL)
(PUSH SEQUENCER ALLFLATS)))
(COND ((AND (ATOM ARGLIST) ;(), or RESTARG
(OR (NULL ARGLIST) (NULL ARGSCHECK))
(NULL ALLFLATS)
(NULL AUX-INISL)
(NULL OPT-INISL) )
(COND ((NULL ARGLIST)
(PUSH (COND ((OR (NULL DCA) RESTARGP) MACROARG)
(`(AND (CDR ,macroarg)
(ERROR '|No args allowed in macro call|
,macroarg))))
BODY))
('T (AND (NOT (EQ ARGLIST RESTARG))
(ERROR '|Bug in DEFMACRO - Why not ARGLIST = &REST arg|
(LIST ARGLIST RESTARG)))
(SETQ MACROARG ARGLIST)
;A simple case - "(DEFMACRO FOO X (mumble-around X))"
(PUSH `(SETQ ,macroarg (CDR ,macroarg)) body))))
('T (SETQ BODY `((COMMENT ARGLIST = ,def-arglist)
,@argscheck
(LET ((,arglist (CDR ,macroarg)) ,@allflats)
,@opt-inisl
,@aux-inisl
,. body)))))
(AND DDC (SETQ BODY `((OR (MACROFETCH ,macroarg)
(MACROMEMO ,macroarg (PROGN ,. body) ',name)))))
(SETQ BODY `(MACRO ,namelist (,macroarg) ,. body))
(COND (DDC `(PROGN 'COMPILE
(|forget-macromemos/|| ',name)
,body ))
('T BODY))))
β